home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / cprim.scm < prev    next >
Text File  |  1995-10-13  |  15KB  |  385 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file cprim.scm.
  6.  
  7. ;;;; Compiling primitive procedures and calls to them.
  8.  
  9. (define (define-compiler-primitive name type compilator closed)
  10.   (define-compilator name type
  11.     (or compilator compile-unknown-call))
  12.   (define-closed-compilator name closed))
  13.  
  14.  
  15. ; Closed-compiled versions of primitives are handled separately.
  16.  
  17. (define closed-compilators 
  18.   (make-operator-table (lambda ()
  19.                          (error "unknown primitive procedure"))))
  20.  
  21. (define (define-closed-compilator name proc)
  22.   (operator-define! closed-compilators name #f proc))
  23.  
  24. ; (primitive-procedure name)  =>  a procedure
  25.  
  26. (define-compilator 'primitive-procedure syntax-type
  27.   (lambda (node cenv depth cont)
  28.     (let ((name (cadr (node-form node))))
  29.       (deliver-value (instruction-with-template
  30.                           (enum op closure)
  31.                           ((get-closed-compilator (get-operator name)))
  32.                           (cont-name cont))
  33.                      cont))))
  34.  
  35. (define (get-closed-compilator op)
  36.   (operator-lookup closed-compilators op))
  37.  
  38.  
  39. ; --------------------
  40. ; Direct primitives.
  41.  
  42. ; The simplest kind of primitive has fixed arity, corresponds to some
  43. ; single VM instruction, and takes its arguments in the usual way (all
  44. ; on the stack except the last).
  45.  
  46. (define (direct-compilator type opcode)
  47.   (lambda (node cenv depth cont)
  48.     (let ((args (cdr (node-form node))))
  49.       (sequentially (if (null? args)
  50.                         empty-segment
  51.                         (push-all-but-last args cenv depth node))
  52.                     (deliver-value (instruction opcode) cont)))))
  53.  
  54. (define (direct-closed-compilator opcode)
  55.   (lambda ()
  56.     (let ((arg-specs (vector-ref opcode-arg-specs opcode)))
  57.       (sequentially (if (pair? arg-specs)
  58.                         (sequentially
  59.                          (instruction (enum op check-nargs=) (car arg-specs))
  60.                          (instruction (enum op pop)))
  61.                         (instruction (enum op check-nargs=) 0))
  62.                     (instruction opcode)
  63.                     (instruction (enum op return))))))
  64.  
  65. (define (nargs->domain nargs)
  66.   (do ((nargs nargs (- nargs 1))
  67.        (l '() (cons value-type l)))
  68.       ((= nargs 0) (make-some-values-type l))))
  69.  
  70.  
  71. ; Define all the primitives that correspond to opcodes in the obvious way.
  72.  
  73. (do ((opcode 0 (+ opcode 1)))
  74.     ((= opcode op-count))
  75.   (let ((arg-specs (vector-ref opcode-arg-specs opcode))
  76.         (name (enumerand->name opcode op)))
  77.     (cond ((memq name '(external-call return-from-interrupt return)))
  78.           ((null? arg-specs)
  79.            (let ((type (proc () value-type)))
  80.              (define-compiler-primitive name type
  81.                (direct-compilator type opcode)
  82.                (direct-closed-compilator opcode))))
  83.           ((not (number? (car arg-specs))))
  84.           (else
  85.            (let ((type (procedure-type (nargs->domain (car arg-specs))
  86.                                        (if (eq? name 'with-continuation)
  87.                                            any-values-type
  88.                                            ;; Return a single value.
  89.                                            value-type)
  90.                                        ;; nonrestrictive - domain might be
  91.                                        ;; specialized later
  92.                                        #t)))
  93.              (define-compiler-primitive name type
  94.                (direct-compilator type opcode)
  95.                (direct-closed-compilator opcode)))))))
  96.  
  97.  
  98. ; --------------------
  99. ; Simple primitives are executed using a fixed instruction or
  100. ; instruction sequence.
  101.  
  102. (define (define-simple-primitive name type segment)
  103.   (let ((winner? (fixed-arity-procedure-type? type)))
  104.     (let ((nargs (if winner?
  105.                      (procedure-type-arity type)
  106.                      (error "n-ary simple primitive?!" name type))))
  107.       (define-compiler-primitive name type
  108.         (simple-compilator segment)
  109.         (simple-closed-compilator nargs segment)))))
  110.  
  111. (define (simple-compilator segment)
  112.   (lambda (node cenv depth cont)
  113.     (let ((args (cdr (node-form node))))
  114.       (sequentially (if (null? args)
  115.                         empty-segment
  116.                         (push-all-but-last args cenv depth node))
  117.                     (deliver-value segment cont)))))
  118.  
  119. (define (simple-closed-compilator nargs segment)
  120.   (lambda ()
  121.     (sequentially (instruction (enum op check-nargs=) nargs)
  122.                   (instruction (enum op pop))
  123.                   segment
  124.                   (instruction (enum op return)))))
  125.  
  126. (define (symbol-append . syms)
  127.   (string->symbol (apply string-append
  128.                          (map symbol->string syms))))
  129.  
  130. (define (define-stob-predicate name stob-name)
  131.   (define-simple-primitive name
  132.     (proc (value-type) boolean-type)
  133.     (instruction (enum op stored-object-has-type?)
  134.                  (name->enumerand stob-name stob))))
  135.  
  136. (define-stob-predicate 'code-vector? 'code-vector)
  137. (define-stob-predicate 'string? 'string)
  138.  
  139. ; Define primitives for record-like stored objects (e.g. pairs).
  140.  
  141. (define (define-data-struct-primitives name predicate maker . slots)
  142.   (let* ((def-prim (lambda (name type op . stuff)
  143.                      (define-simple-primitive name type
  144.                        (apply instruction (cons op stuff)))))
  145.          (type-byte (name->enumerand name stob))
  146.          (type (sexp->type (symbol-append ': name) #t)))
  147.     (define-stob-predicate predicate name)
  148.     (if (not (eq? maker 'make-symbol))  ; Symbols are made using op/intern.
  149.         (def-prim maker
  150.           (procedure-type (nargs->domain (length slots)) type #t)
  151.           (enum op make-stored-object)
  152.           (length slots)
  153.           type-byte))
  154.     (do ((i 0 (+ i 1))
  155.          (slots slots (cdr slots)))
  156.         ((null? slots))
  157.       (let ((slot (car slots)))
  158.         (if (car slot)
  159.             (def-prim (car slot)
  160.               (proc (type) value-type)
  161.               (enum op stored-object-ref) type-byte i))
  162.         (if (cadr slot)
  163.             (def-prim (cadr slot)
  164.               (proc (type value-type) unspecific-type)
  165.               (enum op stored-object-set!) type-byte i))))))
  166.  
  167. (for-each (lambda (stuff)
  168.             (apply define-data-struct-primitives stuff))
  169.           stob-data)
  170.  
  171.  
  172. ; Define primitives for vector-like stored objects.
  173.  
  174. (define (define-vector-primitives name element-type make length ref set!)
  175.   (let* ((type-byte (name->enumerand name stob))
  176.          (def-prim (lambda (name type op)
  177.                      (define-simple-primitive name type
  178.                        (instruction op type-byte))))
  179.          (type (sexp->type (symbol-append ': name) #t)))
  180.     (define-stob-predicate (symbol-append name '?) name)
  181.     (def-prim (symbol-append 'make- name)
  182.       (proc (exact-integer-type element-type) type)
  183.       make)
  184.     (def-prim (symbol-append name '- 'length)
  185.       (proc (type) exact-integer-type)
  186.       length)
  187.     (def-prim (symbol-append name '- 'ref)
  188.       (proc (type exact-integer-type) element-type)
  189.       ref)
  190.     (def-prim (symbol-append name '- 'set!)
  191.       (proc (type exact-integer-type element-type) unspecific-type)
  192.       set!)))
  193.  
  194. (for-each (lambda (name)
  195.             (define-vector-primitives name value-type
  196.               (enum op make-vector-object)
  197.               (enum op stored-object-length)
  198.               (enum op stored-object-indexed-ref)
  199.               (enum op stored-object-indexed-set!)))
  200.           '(vector record continuation extended-number template))
  201.  
  202. ; SIGNAL-CONDITION is the same as TRAP.
  203.  
  204. (define-simple-primitive 'signal-condition (proc (pair-type) unspecific-type)
  205.   (instruction (enum op trap)))
  206.  
  207.  
  208. ; (primitive-catch (lambda (cont) ...))
  209.  
  210. (define-compiler-primitive 'primitive-catch #f
  211.   ;; (primitive-catch (lambda (cont) ...))
  212.   (lambda (node cenv depth cont)
  213.     (let* ((exp (node-form node))
  214.            (args (cdr exp)))
  215.       (maybe-push-continuation
  216.        (sequentially (instruction (enum op current-cont))
  217.                      (instruction (enum op push))
  218.                      ;; If lambda exp, should do compile-lambda-code to
  219.                      ;; avoid consing closure...
  220.                      (compile (car args) cenv 1
  221.                               (fall-through-cont node 1))
  222.                      (instruction (enum op call) 1))
  223.        0
  224.        cont)))
  225.   (lambda ()
  226.     (sequentially (instruction (enum op check-nargs=) 1)
  227.                   (instruction (enum op make-env) 1)  ;Seems unavoidable.
  228.                   (instruction (enum op current-cont))
  229.                   (instruction (enum op push))
  230.                   (instruction (enum op local0) 1)
  231.                   (instruction (enum op call) 1))))  
  232.  
  233. ; (call-with-values (lambda () ...producer...)
  234. ;                   (lambda args ...consumer...))
  235.  
  236. (define-compiler-primitive 'call-with-values #f
  237.   (lambda (node cenv depth cont)
  238.     (let ((args (cdr (node-form node))))
  239.       (let ((producer (car args))
  240.             (consumer (cadr args)))
  241.         (maybe-push-continuation
  242.          (sequentially (compile consumer cenv 0 (fall-through-cont node 2))
  243.                        (instruction (enum op push))
  244.                        (maybe-push-continuation     ; nothing maybe about it
  245.                         (compile-call (classify `(,producer) cenv)
  246.                                       cenv 0
  247.                                       (return-cont #f))
  248.                         1
  249.                         (fall-through-cont #f 0))
  250.                        ;; Was:
  251.                        ;; (compile-call (classify `(,producer) cenv)
  252.                        ;;            cenv 1
  253.                        ;;            (fall-through-cont node 1))
  254.                        (instruction (enum op call-with-values)))
  255.          depth
  256.          cont))))
  257.   (lambda ()
  258.     ;; producer and consumer on stack
  259.     (let ((label (make-label)))
  260.       (sequentially (instruction (enum op check-nargs=) 2)
  261.                     (instruction (enum op make-env) 2)
  262.                     (instruction (enum op local0) 1) ;consumer
  263.                     (instruction (enum op push))
  264.                     (instruction-using-label (enum op make-cont) label 1)
  265.                     (instruction (enum op local0) 2) ;producer
  266.                     (instruction (enum op call) 0)
  267.                     (attach-label label
  268.                                   (instruction (enum op call-with-values)))))))
  269.  
  270.  
  271. ; --------------------
  272. ; Variable-arity primitives
  273.  
  274. (define (define-n-ary-compiler-primitive name result-type min-nargs
  275.                                          compilator closed)
  276.   (define-compiler-primitive name
  277.         (if result-type
  278.             (procedure-type any-arguments-type result-type #f)
  279.             #f)
  280.     (if compilator
  281.         (n-ary-primitive-compilator name min-nargs compilator)
  282.         compile-unknown-call)
  283.     closed))
  284.  
  285. (define (n-ary-primitive-compilator name min-nargs compilator)
  286.   (lambda (node cenv depth cont)
  287.     (let ((exp (node-form node)))
  288.       (if (>= (length (cdr exp)) min-nargs)
  289.           (compilator node cenv depth cont)
  290.           (begin (warn "too few arguments to primitive"
  291.                        (schemify node cenv))
  292.                  (compile-unknown-call node cenv depth cont))))))
  293.  
  294.  
  295. ; APPLY wants to first spread the list, then load the procedure.
  296. ; The list argument has to be in *VAL* so that its length can be checked
  297. ; before the instruction is begun.
  298.  
  299. (define-n-ary-compiler-primitive 'apply #f 2
  300.   (lambda (node cenv depth cont)
  301.     (let ((exp (node-form node)))       ; (apply proc arg1 arg2 arg3 rest)
  302.       (let* ((proc+args+rest (cdr exp))
  303.              (rest+args                 ; (rest arg3 arg2 arg1)
  304.               (reverse (cdr proc+args+rest)))
  305.              (args (cdr rest+args))     ; (arg3 arg2 arg1)
  306.              (args+proc+rest            ; (arg1 arg2 arg3 proc rest)
  307.               (reverse (cons (car rest+args)
  308.                              (cons (car proc+args+rest) args)))))
  309.         (maybe-push-continuation
  310.          (sequentially (push-all-but-last args+proc+rest cenv 0 #f)
  311.                        ;; Operand is number of non-final arguments
  312.                        (instruction (enum op apply) (length args)))
  313.          depth
  314.          cont))))
  315.   (lambda ()
  316.     (sequentially (instruction (enum op check-nargs=) 2)
  317.                   (instruction (enum op pop))
  318.                   (instruction (enum op apply) 0))))
  319.  
  320.  
  321. ; (values value1 value2 ...)
  322.  
  323. (define-n-ary-compiler-primitive 'values #f 0
  324.   (lambda (node cenv depth cont)
  325.     (let ((args (cdr (node-form node))))
  326.       (maybe-push-continuation (sequentially (push-arguments node cenv 0)
  327.                                              (instruction (enum op return-values)
  328.                                                           (length args)))
  329.                                depth
  330.                                cont)))
  331.   (lambda () (instruction (enum op values))))
  332.  
  333.  
  334. ; (error message irritant1 irritant2)
  335. ;  => (trap (cons 'error (cons message (cons irritant1 (cons irritant2 '())))))
  336.  
  337. (let ((cons-instruction
  338.        (instruction (enum op make-stored-object) 2 (enum stob pair))))
  339.  
  340.   (define-n-ary-compiler-primitive 'error error-type 1
  341.     (lambda (node cenv depth cont)
  342.       (let ((exp (node-form node)))
  343.         (let ((args (cdr exp)))
  344.           (sequentially (instruction-with-literal (enum op literal) 'error)
  345.                         (instruction (enum op push))
  346.                         (push-arguments node cenv (+ depth 1))
  347.                         (instruction-with-literal (enum op literal) '())
  348.                         (apply sequentially
  349.                                (map (lambda (arg) cons-instruction) args))
  350.                         cons-instruction
  351.                         (deliver-value (instruction (enum op trap)) cont)))))
  352.     (lambda ()
  353.       (sequentially (instruction (enum op make-rest-list) 0)
  354.                     (instruction (enum op push))
  355.                     (instruction-with-literal (enum op literal) 'error)
  356.                     (instruction (enum op push))
  357.                     (instruction (enum op stack-ref) 1)
  358.                     cons-instruction
  359.                     (instruction (enum op trap))
  360.                     (instruction (enum op return))))))
  361.  
  362.  
  363. ; (external-call external-routine arg ...)
  364.  
  365. (define-n-ary-compiler-primitive 'external-call value-type 1
  366.   #f                                         ;Must set *nargs*
  367.   (lambda ()
  368.     (sequentially (instruction (enum op check-nargs>=) 1)
  369.                   (instruction (enum op external-call))
  370.                   (instruction (enum op return)))))
  371.  
  372.  
  373. ; --------------------
  374. ; Utility
  375.  
  376. (define (push-all-but-last args cenv depth source-info)
  377.   (let recur ((args args) (depth depth) (i 1))
  378.     (let ((first-code
  379.            (compile (car args) cenv depth (fall-through-cont source-info i))))
  380.       (if (null? (cdr args))
  381.           first-code
  382.           (sequentially first-code
  383.                         (instruction (enum op push))
  384.                         (recur (cdr args) (+ depth 1) (+ i 1)))))))
  385.